home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / vm-type.lisp < prev    next >
Encoding:
Text File  |  1991-12-16  |  5.8 KB  |  187 lines
  1. ;;; -*- Package: KERNEL; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: vm-type.lisp,v 1.28 91/12/16 10:09:55 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: vm-type.lisp,v 1.28 91/12/16 10:09:55 wlott Exp $
  15. ;;;
  16. ;;;    This file contains implementation-dependent parts of the type support
  17. ;;; code.  This is stuff which deals with the mapping from types defined in
  18. ;;; Common Lisp to types actually supported by an implementation.
  19. ;;;
  20. ;;; Written by Rob MacLachlan
  21. ;;;
  22. (in-package "KERNEL")
  23.  
  24.  
  25. ;;;; Implementation dependent deftypes:
  26.  
  27. ;;; Make double-float a synonym for long-float, single-float for Short-Float.
  28. ;;; This is be expanded before the translator gets a chance, so we will get
  29. ;;; precedence.
  30. ;;;
  31. (setf (info type kind 'long-float) :defined)
  32. (deftype long-float (&optional low high)
  33.   `(double-float ,low ,high))
  34. ;;;
  35. (setf (info type kind 'short-float) :defined)
  36. (deftype short-float (&optional low high)
  37.   `(single-float ,low ,high))
  38.  
  39. ;;; Compiled-function is the same as function in this implementation.
  40. ;;;
  41. (deftype compiled-function () 'function)
  42.  
  43. ;;; Character is the same as base-char.
  44. (setf (info type builtin 'character) nil)
  45. (setf (info type kind 'character) :defined)
  46. (deftype character () 'base-char)
  47.  
  48. ;;;
  49. ;;; An index into an integer.
  50. (deftype bit-index () `(integer 0 ,most-positive-fixnum))
  51. ;;;
  52. ;;; Offset argument to Ash (a signed bit index).
  53. (deftype ash-index () 'fixnum)
  54. ;;;
  55. ;;; A lexical environment for macroexpansion.
  56. (deftype lexical-environment () 'c::lexenv)
  57. ;;;
  58. ;;; Worst case values for float attributes.
  59. ;;;
  60. (deftype float-exponent () 'double-float-exponent)
  61. (deftype float-digits () `(integer 0 ,vm:double-float-digits))
  62. (deftype float-radix () '(integer 2 2))
  63. ;;;
  64. ;;; A code for Boole.
  65. (deftype boole-code () '(unsigned-byte 4))
  66. ;;;
  67. ;;; A byte-specifier.
  68. (deftype byte-specifier () 'cons)
  69. ;;;
  70. ;;; Result of Char-Int...
  71. (deftype char-int () 'char-code)
  72. ;;;
  73. ;;; Pathname pieces, as returned by the PATHNAME-xxx functions.
  74. (deftype pathname-host () '(or lisp::host null))
  75. (deftype pathname-device () '(member nil :unspecific))
  76. (deftype pathname-directory () 'list)
  77. (deftype pathname-name () '(or simple-string lisp::pattern null))
  78. (deftype pathname-type ()
  79.   '(or simple-string lisp::pattern (member nil :unspecific)))
  80. (deftype pathname-version () '(or integer (member nil :newest :wild)))
  81. ;;;
  82. ;;; Internal time format.  Not a fixnum (blag...)
  83. (deftype internal-time () 'unsigned-byte)
  84.  
  85. (deftype bignum-element-type () `(unsigned-byte ,vm:word-bits))
  86. (deftype bignum-type () 'bignum)
  87. (deftype bignum-index () 'index)
  88.  
  89. (deftype structure-index () `(unsigned-byte ,(- vm:word-bits vm:type-bits)))
  90.  
  91.  
  92. ;;;; Hooks into type system:
  93.  
  94. ;;; The kinds of specialised array that actually exist in this implementation.
  95. ;;;
  96. (defparameter specialized-array-element-types
  97.   '(bit (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16)
  98.     (unsigned-byte 32) base-char single-float double-float))
  99.  
  100. (deftype unboxed-array (&optional dims)
  101.   (collect ((types (list 'or)))
  102.     (dolist (type specialized-array-element-types)
  103.       (when (subtypep type '(or integer character float))
  104.     (types `(array ,type ,dims))))
  105.     (types)))
  106.  
  107. (deftype simple-unboxed-array (&optional dims)
  108.   (collect ((types (list 'or)))
  109.     (dolist (type specialized-array-element-types)
  110.       (when (subtypep type '(or integer character float))
  111.     (types `(simple-array ,type ,dims))))
  112.     (types)))
  113.  
  114.  
  115. ;;; Float-Format-Name  --  Internal
  116. ;;;
  117. ;;;    Return the symbol that describes the format of Float.
  118. ;;;
  119. (proclaim '(function float-format-name (float) symbol))
  120. (defun float-format-name (x)
  121.   (etypecase x
  122.     (single-float 'single-float)
  123.     (double-float 'double-float)))
  124.  
  125. ;;; Specialize-Array-Type  --  Internal
  126. ;;;
  127. ;;;    This function is called when the type code wants to find out how an
  128. ;;; array will actually be implemented.  We set the Specialized-Element-Type to
  129. ;;; correspond to the actual specialization used in this implementation.
  130. ;;;
  131. (proclaim '(function specialize-array-type (array-type) array-type))
  132. (defun specialize-array-type (type)
  133.   (let ((eltype (array-type-element-type type)))
  134.  
  135.     (setf (array-type-specialized-element-type type)
  136.       (if (eq eltype *wild-type*)
  137.           *wild-type*
  138.           (dolist (stype-name specialized-array-element-types
  139.                   (specifier-type 't))
  140.         (let ((stype (specifier-type stype-name)))
  141.           (when (csubtypep eltype stype)
  142.             (return stype))))))
  143.  
  144.     type))
  145.  
  146.  
  147. ;;; Contaning-Integer-Type  --  Interface
  148. ;;;
  149. ;;; Return the most specific integer type that can be quickly checked that
  150. ;;; includes the given type.
  151. ;;; 
  152. (defun containing-integer-type (subtype)
  153.   (dolist (type '(fixnum
  154.           (signed-byte 32)
  155.           (unsigned-byte 32)
  156.           integer)
  157.         (error "~S isn't an integer type?" subtype))
  158.     (when (csubtypep subtype (specifier-type type))
  159.       (return type))))
  160.  
  161.  
  162. ;;; Hairy-Type-Check-Template  --  Interface
  163. ;;;
  164. ;;;    If Type has a CHECK-xxx template, but doesn't have a corresponding
  165. ;;; primitive-type, then return the template's name.  Otherwise, return NIL.
  166. ;;;
  167. (defun hairy-type-check-template (type)
  168.   (declare (type ctype type))
  169.   (typecase type
  170.     (named-type
  171.      (case (named-type-name type)
  172.        (cons 'c:check-cons)
  173.        (symbol 'c:check-symbol)
  174.        (t nil)))
  175.     (numeric-type
  176.      (cond ((type= type (specifier-type 'fixnum))
  177.         'c:check-fixnum)
  178.        ((type= type (specifier-type '(signed-byte 32)))
  179.         'c:check-signed-byte-32)
  180.        ((type= type (specifier-type '(unsigned-byte 32)))
  181.         'c:check-unsigned-byte-32)
  182.        (t nil)))
  183.     (function-type
  184.      'c:check-function)
  185.     (t
  186.      nil)))
  187.